home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap04 / howto08 / delphi10 / ccprnmgr.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-11-26  |  17.2 KB  |  500 lines
  1. unit Ccprnmgr;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Printers, DRWSUtl1, PPrevUn;
  8.  
  9. type
  10.   TCCPrintForm = class(TForm)
  11.     ComboBox1: TComboBox;
  12.     Label1: TLabel;
  13.     BitBtn1: TBitBtn;
  14.     BitBtn3: TBitBtn;
  15.     BitBtn4: TBitBtn;
  16.     Bevel1: TBevel;
  17.     Label2: TLabel;
  18.     Label3: TLabel;
  19.     Label4: TLabel;
  20.     Bevel2: TBevel;
  21.     Label5: TLabel;
  22.     Label6: TLabel;
  23.     Bevel3: TBevel;
  24.     ListBox1: TListBox;
  25.     Label7: TLabel;
  26.     BitBtn6: TBitBtn;
  27.     BitBtn7: TBitBtn;
  28.     BitBtn8: TBitBtn;
  29.     Label8: TLabel;
  30.     Label9: TLabel;
  31.     Label10: TLabel;
  32.     Label11: TLabel;
  33.     RadioGroup1: TRadioGroup;
  34.     BitBtn9: TBitBtn;
  35.     FontDialog1: TFontDialog;
  36.     BitBtn10: TBitBtn;
  37.     BitBtn11: TBitBtn;
  38.     BitBtn12: TBitBtn;
  39.     PrintDialog1: TPrintDialog;
  40.     PrinterSetupDialog1: TPrinterSetupDialog;
  41.     procedure FormCreate(Sender: TObject);
  42.     procedure BitBtn1Click(Sender: TObject);
  43.     procedure BitBtn7Click(Sender: TObject);
  44.     procedure BitBtn9Click(Sender: TObject);
  45.     procedure RadioGroup1Click(Sender: TObject);
  46.     procedure BitBtn6Click(Sender: TObject);
  47.     procedure BitBtn4Click(Sender: TObject);
  48.     procedure BitBtn8Click(Sender: TObject);
  49.     procedure BitBtn10Click(Sender: TObject);
  50.     procedure BitBtn12Click(Sender: TObject);
  51.     procedure BitBtn11Click(Sender: TObject);
  52.   private
  53.     { Private declarations }
  54.   public
  55.     { Public declarations }
  56.     procedure HandlePrinting;
  57.     procedure DumpScreenToPrinter( PrintToFile : Boolean );
  58.     procedure HandlePrintPreview;
  59.   end;
  60.  
  61. var
  62.   CCPrintForm: TCCPrintForm;
  63.  
  64. implementation
  65.  
  66. {$R *.DFM}
  67.  
  68. procedure TCCPrintForm.HandlePrintPreview;
  69. var TheRatio : double;
  70.     TheMultiple,
  71.     RealWidth ,
  72.     RealHeight   : Integer;
  73.     TheBitmap : TBitmap;
  74.     ScreenDC : HDC;
  75.     TheResult : Boolean;
  76. begin
  77.   { Create the bitmap and put screen image in it }
  78.   TheBitmap := TBitmap.Create;
  79.   TheBitmap.Width := Screen.Width;
  80.   TheBitmap.Height := Screen.Height;
  81.   ScreenDC := GetDC( 0 );
  82.   TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  83.           ScreenDC , 0 , 0 , SRCCOPY );
  84.   ReleaseDC( 0 , ScreenDC );
  85.   { This shows the position of a screen dump on the printed page }
  86.   PrintPreviewForm := TPrintPreviewForm.Create( Application );
  87.   TheMultiple := Round( Printer.PageWidth/Screen.Width ) - 1;
  88.   TheRatio := PrintPreviewForm.Panel2.Width/Printer.PageWidth;
  89.   RealWidth := Round( TheRatio * TheBitmap.Width * TheMultiple );
  90.   RealHeight := Round( TheRatio * TheBitmap.Height * TheMultiple );
  91.   PrintPreviewForm.Image1.Width := RealWidth;
  92.   PrintPreviewForm.Image1.Height := RealHeight;
  93.   PrintPreviewForm.Image1.Picture.Bitmap := TheBitmap;
  94.   PrintPreviewForm.ShowModal;
  95.   PrintPreviewForm.Free;
  96.   TheBitmap.Free;
  97. end;
  98.  
  99. procedure TCCPrintForm.DumpScreenToPrinter( PrintToFile : Boolean );
  100. var TheBitmap : TBitmap;
  101.     ScreenDC : HDC;
  102.     Info: PBitmapInfo;
  103.     InfoSize: Integer;
  104.     Image: Pointer;
  105.     ImageSize: Longint;
  106.     Bits: HBITMAP;
  107.     DIBWidth, DIBHeight: Longint;
  108.     PrintWidth, PrintHeight: Longint;
  109.     TheResult : Boolean;
  110.     PrinterMult : Integer;
  111.     OpenDialog1 : TOpenDialog;
  112. begin
  113.   { External try/except loop to get errors }
  114.   try
  115.     { Start the print }
  116.     if not PrintToFile then Printer.BeginDoc;
  117.     { Create the bitmap and put screen image in it }
  118.     TheBitmap := TBitmap.Create;
  119.     TheBitmap.Width := Screen.Width;
  120.     TheBitmap.Height := Screen.Height;
  121.     ScreenDC := GetDC( 0 );
  122.     TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  123.             ScreenDC , 0 , 0 , SRCCOPY );
  124.     ReleaseDC( 0 , ScreenDC );
  125.     { Get the aspect ration printer to screen, less 1 for overruns }
  126.     PrinterMult := Round( Printer.PageWidth / Screen.Width ) - 1;
  127.     if PrintToFile then
  128.     begin
  129.       OpenDialog1 := TOpenDialog.Create( Application );
  130.       OpenDialog1.Filter := 'Windows Bitmaps|*.bmp|All Files|*.*';
  131.       OpenDialog1.Filename := '*.bmp';
  132.       OpenDialog1.Title := 'Save Screen Dump As...';
  133.       if OpenDialog1.Execute then TheBitmap.SaveToFile( OpenDialog1.FileName );
  134.       TheBitmap.Free;
  135.       OpenDialog1.Free;
  136.       exit;
  137.     end;
  138.     { Do a StretchDIBits due to a canvas bug in delphi printing }
  139.     Bits := TheBitmap.Handle;
  140.     GetDIBSizes(Bits, InfoSize, ImageSize);
  141.     Info := MemAlloc(InfoSize);
  142.     try
  143.       Image := MemAlloc(ImageSize);
  144.       try
  145.         GetDIB(Bits, 0, Info^, Image^);
  146.         with Info^.bmiHeader do
  147.         begin
  148.           DIBWidth := biWidth;
  149.           DIBHeight := biHeight;
  150.         end;
  151.         PrintWidth := DIBWidth * PrinterMult;
  152.         PrintHeight := DIBHeight * PrinterMult;
  153.         StretchDIBits(Printer.Canvas.Handle, 10 , 10 , PrintWidth, PrintHeight, 0, 0,
  154.          DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  155.       finally
  156.           FreeMem(Image, ImageSize);
  157.       end;
  158.     finally
  159.       FreeMem(Info, InfoSize);
  160.     end;
  161.     TheBitmap.Free;
  162.     { Send the bitmap to the printer }
  163.     if not Printer.Aborted then Printer.EndDoc;
  164.   except
  165.     { Assume HandlePrint reraises exception }
  166.     On E:EPrinter do
  167.     begin
  168.       { Beep on error }
  169.       MessageBeep( MB_ICONEXCLAMATION );
  170.       { Set status label color to red }
  171.       Label6.Font.Color := clRed;
  172.       { Set the caption to the error message }
  173.       Label6.Caption := E.Message;
  174.       { If any exceptions occur chicken out and dump }
  175.       Printer.Abort;
  176.       exit;
  177.     end;
  178.     On E: Exception do
  179.     begin
  180.       raise;
  181.       exit;
  182.     end;
  183.   end;
  184. end;
  185.  
  186. procedure TCCPrintForm.HandlePrinting;
  187. var TheFile      : TextFile;    { Used to open text files     }
  188.     TheBitmap    : TBitmap;     { Used to open bitmap files   }
  189.     Counter_1 ,                 { Loop Counter for Selections }
  190.     Counter_2    : Integer;     { Loop Counter for lines      }
  191.     TheString    : String;      { Text file IO handler        }
  192.     TestString   : String;      { Used to check file extension}
  193.     Info         : PBitmapInfo; { Used to print bitmap        }
  194.     InfoSize     : Integer;     { Used to print bitmap        }
  195.     Image        : Pointer;     { Used to print bitmap        }
  196.     ImageSize    : Longint;     { Used to print bitmap        }
  197.     Bits         : HBITMAP;     { Used to print bitmap        }
  198.     DIBWidth ,                  { Used to print bitmap        }
  199.     DIBHeight    : Longint;     { Used to print bitmap        }
  200.     PrintWidth ,                { Used to print bitmap        }
  201.     PrintHeight  : Longint;     { Used to print bitmap        }
  202. begin
  203.   { Print text and bitmap files directly and shell all }
  204.   { other files out to windows to print, if possible.  }
  205.   for Counter_1 := 0 to Listbox1.Items.Count - 1 do
  206.   begin
  207.     { Allow checks for hitting abort button }
  208.     Application.ProcessMessages;
  209.     if Printer.Aborted then exit;
  210.     { Check for selected file in the listbox to do a print }
  211.     if ListBox1.Selected[ Counter_1 ] then
  212.     begin
  213.       { Check against extension of file selected }
  214.       TestString := Uppercase( ExtractFileExt( ListBox1.Items[ Counter_1 ] ));
  215.       if TestString = '.TXT' then
  216.       begin { Print out text files directly to demo method }
  217.         { Call begindoc method }
  218.         Printer.BeginDoc;
  219.         try
  220.           { Try to assign and open the file, barf if can't }
  221.           AssignFile( TheFile , ListBox1.Items[ Counter_1 ] );
  222.           Reset( TheFile );
  223.           { Set the lines printed counter }
  224.           Counter_2 := 1;
  225.           { Run to the end of the file }
  226.           while not EOF( TheFile ) do
  227.           begin
  228.             { Allow the user to abort }
  229.             Application.ProcessMessages;
  230.             if Printer.Aborted then
  231.             begin
  232.               { Display brief abort message }
  233.               Label6.Font.Color := clRed;
  234.               Label6.Caption := 'Aborting...';
  235.               Label6.Show;
  236.               { Go bye bye }
  237.               exit;
  238.             end;
  239.             { Do the actual printing with textout }
  240.             { Read the next line in               }
  241.             Readln( TheFile , TheString );
  242.             { Put it out down the page per line }
  243.             Printer.Canvas.TextOut( 10 , 20 +
  244.              ( Counter_2  * ( Printer.Canvas.TextHeight( 'W' ) + 5 )) ,
  245.               TheString );
  246.             { Increment the line counter and test for end of page }
  247.             Counter_2 := Counter_2 + 1;
  248.             if (( Counter_2 * ( Printer.Canvas.TextHeight( 'W' ) +
  249.              5 )) + 20 ) > ( Printer.PageHeight - 20 ) then
  250.             begin
  251.               { Send a form feed to printer and reset line counter }
  252.               Printer.NewPage;
  253.               Counter_2 := 1;
  254.             end;
  255.           end;
  256.           { Close the file being printed }
  257.           CloseFile( TheFile );
  258.         except
  259.           { Assume HandlePrint reraises exception }
  260.           On E:EPrinter do
  261.           begin
  262.             { Beep on error }
  263.             MessageBeep( MB_ICONEXCLAMATION );
  264.             { Set status label color to red }
  265.             Label6.Font.Color := clRed;
  266.             { Set the caption to the error message }
  267.             Label6.Caption := E.Message;
  268.             { If any exceptions occur chicken out and dump }
  269.             Printer.Abort;
  270.             exit;
  271.           end;
  272.         end;
  273.         { Call Enddoc method }
  274.         Printer.EndDoc;
  275.       end
  276.       else
  277.       begin
  278.         if TestString = '.BMP' then
  279.         begin { Print out bitmap files directly to demo method }
  280.           { If not graphics capabile signal error }
  281.           if Label9.Caption = 'Graphics Capable'
  282.           then
  283.           begin
  284.             { Otherwise create the bitmap and load the file }
  285.             TheBitmap := TBitmap.Create;
  286.             try
  287.               TheBitmap.LoadFromFile( ListBox1.Items[ Counter_1 ] );
  288.             except
  289.               { Abort on error }
  290.               raise;
  291.               exit;
  292.             end;
  293.             try
  294.               { Start the printing }
  295.               {Printer.BeginDoc;}
  296.               { Perform magic since normal canvas stuff won't work! }
  297.               with Printer, Canvas do
  298.               begin
  299.                 { Get a handle to the bitmap's data }
  300.                 Bits := TheBitmap.Handle;
  301.                 { Find out memory requirements }
  302.                 GetDIBSizes(Bits, InfoSize, ImageSize);
  303.                 { Get a pointer to enough memory for structure }
  304.                 Info := MemAlloc(InfoSize);
  305.                 try
  306.                   { Now try to hold the bits }
  307.                   Image := MemAlloc(ImageSize);
  308.                   try
  309.                     { And conver them to Device Independent }
  310.                     GetDIB(Bits, 0, Info^, Image^);
  311.                     with Info^.bmiHeader do
  312.                     begin
  313.                       { Get width and height when done }
  314.                       DIBWidth := biWidth;
  315.                       DIBHeight := biHeight;
  316.                     end;
  317.                     { Set these to enlarge but could scale }
  318.                     PrintWidth := DIBWidth * 3;
  319.                     PrintHeight := DIBHeight * 3;
  320.                     { Do actual print via StretchDIBits API call }
  321.                     StretchDIBits(Canvas.Handle, 20 , 20 , PrintWidth,
  322.                      PrintHeight, 0, 0, DIBWidth, DIBHeight, Image,
  323.                       Info^, DIB_RGB_COLORS, SRCCOPY);
  324.                   finally
  325.                     { Release memory regardless }
  326.                     FreeMem(Image, ImageSize);
  327.                   end;
  328.                 finally
  329.                   { Release more memory regardless }
  330.                   FreeMem(Info, InfoSize);
  331.                   { Free the bitmap }
  332.                   TheBitmap.Free;
  333.                 end;
  334.               end;
  335.               { End the printing }
  336.               Printer.EndDoc;
  337.             except
  338.               { Assume HandlePrint reraises exception }
  339.               On E:EPrinter do
  340.               begin
  341.                 { Beep on error }
  342.                 MessageBeep( MB_ICONEXCLAMATION );
  343.                 { Set status label color to red }
  344.                 Label6.Font.Color := clRed;
  345.                 { Set the caption to the error message }
  346.                 Label6.Caption := E.Message;
  347.                 { If any exceptions occur chicken out and dump }
  348.                 Printer.Abort;
  349.                 exit;
  350.               end;
  351.             end;
  352.           end
  353.           { Complain about printing to nonraster device! }
  354.           else MessageDlg( 'Cannot Print A Bitmap On Non-Graphics Printer!',
  355.            mtError, [mbOK],0 );
  356.         end
  357.         else
  358.         begin
  359.           { Otherwise try to shell out to windows to print complex file }
  360.           if not ShellExec( ExpandFileName( ListBox1.Items[ Counter_1 ] )
  361.             , '' , '', true , SW_SHOWMINIMIZED , true ) then
  362.             MessageDlg('Could not Print ' + ListBox1.Items[ Counter_1 ] ,
  363.              mtError, [mbOK], 0);
  364.         end;
  365.       end;
  366.     end;
  367.   end;
  368. end;
  369.  
  370. procedure TCCPrintForm.FormCreate(Sender: TObject);
  371. begin
  372.   { Clear the combobox and assign the available printers }
  373.   Combobox1.Clear;
  374.   Combobox1.Items.Assign( Printer.Printers );
  375.   Combobox1.Itemindex := Printer.PrinterIndex;
  376.   { Display currently active printer }
  377.   Label4.Caption := Printer.Printers[ Printer.PrinterIndex ];
  378.   { Display resolution of currently active printer }
  379.   Label11.Caption := 'Width: ' + InttoStr( Printer.PageWidth ) +
  380.    ' Height: ' + IntToStr( Printer.PageHeight );
  381.   { Display orientation of currently active printer }
  382.   case Printer.Orientation of
  383.     poPortrait  : RadioGroup1.ItemIndex := 0;
  384.     poLandscape : RadioGroup1.ItemIndex := 1;
  385.   end;
  386.   { Set label for status }
  387.   Label6.Font.Color := clBlack;
  388.   Label6.Caption := 'Idle';
  389.   { Determine basic device capabilities of the selected printer }
  390.   if GetDeviceCaps( Printer.Handle , TECHNOLOGY ) = DT_RASPRINTER then
  391.    Label9.Caption := 'Graphics Capable' else Label9.Caption := 'Character Device';
  392.   if GetDeviceCaps( Printer.Handle , BITSPIXEL ) > 1 then
  393.    Label8.Caption := 'Color Capable' else Label8.Caption := 'Monochrome';
  394.   Label10.Caption := 'Resolution: ' +
  395.    IntToStr( GetDeviceCaps( Printer.Handle , LOGPIXELSX )) + ' dpi';
  396. end;
  397.  
  398. procedure TCCPrintForm.BitBtn1Click(Sender: TObject);
  399. begin
  400.   { Set the Default printer to be the selection of the combobox }
  401.   Printer.PrinterIndex := ComboBox1.ItemIndex;
  402.   { And cleverly reset the display! }
  403.   FormCreate( Self );
  404. end;
  405.  
  406. procedure TCCPrintForm.BitBtn7Click(Sender: TObject);
  407. begin
  408.   { This just runs the printer setup dialog }
  409.   PrinterSetupDialog1.Execute;
  410. end;
  411.  
  412. procedure TCCPrintForm.BitBtn9Click(Sender: TObject);
  413. begin
  414.   { This just displays available fonts for the printer }
  415.   if FontDialog1.Execute then Printer.Canvas.Font := FontDialog1.Font;
  416. end;
  417.  
  418. procedure TCCPrintForm.RadioGroup1Click(Sender: TObject);
  419. begin
  420.   { Set the printer orientation based on the radiogroup itemindex }
  421.   case RadioGroup1.ItemIndex of
  422.     0 : Printer.Orientation := poPortrait;
  423.     1 : Printer.Orientation := poLandscape;
  424.   end;
  425. end;
  426.  
  427. procedure TCCPrintForm.BitBtn6Click(Sender: TObject);
  428. begin
  429.   { If execute print dialog then call HandlePrint method and deal with exceptions }
  430.   if PrintDialog1.Execute then
  431.   begin
  432.     { Reset Label font color }
  433.     Label6.Font.Color := clBlack;
  434.     { Change status label to printing }
  435.     Label6.Caption := 'Printing...';
  436.     { Call HandlePrinting Method }
  437.     HandlePrinting;
  438.     { Reset the display to indicate printing not in progress }
  439.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  440.   end;
  441. end;
  442.  
  443. procedure TCCPrintForm.BitBtn4Click(Sender: TObject);
  444. begin
  445.   { If already printing do abort }
  446.   if Printer.Printing then
  447.   begin
  448.     { call abort method }
  449.     Printer.Abort;
  450.     { Reset status label }
  451.     Label6.Font.Color := clBlack;
  452.     Label6.Caption := 'Aborted...';
  453.   end;
  454. end;
  455.  
  456. procedure TCCPrintForm.BitBtn8Click(Sender: TObject);
  457. begin
  458.   if not ShellExec( 'C:\WINDOWS\PRINTMAN.EXE', '' , '', false ,
  459.    SW_SHOWNORMAL , false ) then
  460.     MessageDlg('Could not locate Print Manager!', mtError, [mbOK], 0);
  461. end;
  462.  
  463. procedure TCCPrintForm.BitBtn10Click(Sender: TObject);
  464. begin
  465.   if PrintDialog1.Execute then
  466.   begin
  467.     { Reset Label font color }
  468.     Label6.Font.Color := clBlack;
  469.     { Change status label to printing }
  470.     Label6.Caption := 'Printing...';
  471.     { Call Print Screen Method }
  472.     DumpScreenToPrinter( false );
  473.     { Reset the display to indicate printing not in progress }
  474.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  475.   end;
  476. end;
  477.  
  478. procedure TCCPrintForm.BitBtn12Click(Sender: TObject);
  479. begin
  480.   if PrintDialog1.Execute then
  481.   begin
  482.     { Reset Label font color }
  483.     Label6.Font.Color := clBlack;
  484.     { Change status label to printing }
  485.     Label6.Caption := 'Printing...';
  486.     { Call Print Screen Method }
  487.     DumpScreenToPrinter( PrintDialog1.PrintToFile );
  488.     { Reset the display to indicate printing not in progress }
  489.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  490.   end;
  491. end;
  492.  
  493. procedure TCCPrintForm.BitBtn11Click(Sender: TObject);
  494. begin
  495.   { Call the HPP routine }
  496.   HandlePrintPreview;
  497. end;
  498.  
  499. end.
  500.